home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol285 / alphamar.bas (.txt) next >
Encoding:
GW-BASIC  |  1987-03-15  |  4.8 KB  |  166 lines
  1. 100  REM ALPHAMAR Program.
  2. 110  REM Prints an Alphabetic List of Marriages
  3. 120  REM Copyright (c) 1983 - 1987 by: Melvin O. Duke.
  4. 130  DEFINT A-Z
  5. 600  REM Titles
  6. 610  TITLE$ = "Alphabetic List of Marriages"
  7. 620  TITLE$ = TITLE$ + " ON DISPLAY"
  8. 700  REM Terminate if not called from the Menu
  9. 710  IF DD.MENU$ <> "" THEN 770
  10. 720  COLOR 7,0 : KEY ON : CLS : LOCATE 15,1
  11. 730  PRINT "Cannot run the"
  12. 740  PRINT TITLE$
  13. 750  PRINT "Program, unless selected from the MENU"
  14. 760  END
  15. 770  REM OK
  16. 900  REM Dimension Statements
  17. 910  DIM PERS.ID(2*MAX.MAR), MARR.ID(2*MAX.MAR), IDX$(2*MAX.MAR)
  18. 1000  REM Produce the first screen
  19. 1010  KEY ON : CLS : KEY OFF
  20. 1020  REM Draw the outer double box
  21. 1030  R1 = 1 : C1 = 1 : R2 = 24 : C2 = 79 : GOSUB 1300
  22. 1040  REM Find the title location
  23. 1050  TITLE.POS = 40 - INT(LEN(TITLE$)/2)
  24. 1060  REM Draw the title box
  25. 1070  R1=3:C1=TITLE.POS-2:R2=6:C2=TITLE.POS+LEN(TITLE$)+1:GOSUB 1500
  26. 1080  REM Print the title
  27. 1090  LOCATE 4,TITLE.POS : PRINT TITLE$
  28. 1100  LOCATE 5,40-INT(LEN(VERSION$)/2) :  PRINT VERSION$;
  29. 1230  REM Draw the Copyright box
  30. 1240  R1 = 19 : C1 = 21 : R2 = 22 : C2 = 59 : GOSUB 1300
  31. 1250  REM Print the Copyright
  32. 1260  LOCATE 20,40-INT(LEN(COPY1$)/2) :  PRINT COPY1$;
  33. 1270  LOCATE 21,40-INT(LEN(COPY2$)/2) :  PRINT COPY2$;
  34. 1280  GOTO 1700
  35. 1300  REM subroutine to print a double box
  36. 1310  COLOR P
  37. 1320  FOR I = R1 + 1 TO R2 - 1
  38. 1330   LOCATE I, C1 : PRINT CHR$(186);
  39. 1340   LOCATE I, C2 : PRINT CHR$(186);
  40. 1350  NEXT I
  41. 1360   LOCATE R1, C1+1 : PRINT STRING$(C2-C1-1,205);
  42. 1390   LOCATE R2, C1+1 : PRINT STRING$(C2-C1-1,205);
  43. 1400   LOCATE R1, C1 : PRINT CHR$(201);
  44. 1410   LOCATE R1, C2 : PRINT CHR$(187);
  45. 1420   LOCATE R2, C1 : PRINT CHR$(200);
  46. 1430   LOCATE R2, C2 : PRINT CHR$(188);
  47. 1440  COLOR W
  48. 1450  RETURN
  49. 1500  REM subroutine to print a single box
  50. 1510  COLOR B
  51. 1520  FOR I = R1 + 1 TO R2 - 1
  52. 1530   LOCATE I, C1 : PRINT CHR$(179);
  53. 1540   LOCATE I, C2 : PRINT CHR$(179);
  54. 1550  NEXT I
  55. 1560   LOCATE R1, C1+1 : PRINT STRING$(C2-C1-1,196);
  56. 1590   LOCATE R2, C1+1 : PRINT STRING$(C2-C1-1,196);
  57. 1600   LOCATE R1, C1 : PRINT CHR$(218);
  58. 1610   LOCATE R1, C2 : PRINT CHR$(191);
  59. 1620   LOCATE R2, C1 : PRINT CHR$(192);
  60. 1630   LOCATE R2, C2 : PRINT CHR$(217);
  61. 1640  COLOR W
  62. 1650  RETURN
  63. 1700  REM ask user to press a key to continue
  64. 1710  LOCATE 25,1
  65. 1720  PRINT "Have Data Diskette(s) in Place, then Press any key to continue.";
  66. 1730  K$ = INKEY$ : IF K$ = "" THEN 1730
  67. 1740  KEY ON : CLS : KEY OFF
  68. 2000  REM ALPHAMAR Program Starts Here.
  69. 2010  OPEN DD.PERS$+"persfile" AS #1 LEN = 256
  70. 2020  FIELD 1, 5 AS F1$, 20 AS F2$, 30 AS F3$, 2 AS F4$, 5 AS F5$, 5 AS F6$, 5 AS F7$, 11 AS F8$, 18 AS F9$, 16 AS F10$, 16 AS F11$, 11 AS F12$, 18 AS F13$, 16 AS F14$, 16 AS F15$, 11 AS F16$, 18 AS F17$, 16 AS F18$, 16 AS F19$
  71. 2030  REM Read the Marriage Index and then the Person File
  72. 2040  KEY ON : CLS : KEY OFF
  73. 2050  OPEN DD.MARIDX$+"mindex" FOR INPUT AS #2
  74. 2060  INPUT #2, CX
  75. 2070  LOCATE 19,1 : PRINT "There are:";CX;"Marriage Index Records"
  76. 2080  C = 0
  77. 2090  FOR I = 1 TO CX
  78. 2100  C = C + 1
  79. 2110   INPUT #2, PERS.ID(I), MARR.ID(I)
  80. 2120   LOCATE 23,1 : PRINT "Processing Marriage Index Record:";I,"Freespace";FRE(0)
  81. 2130   REM get the personal information
  82. 2140   GET #1, PERS.ID(I)
  83. 2150   REM Extract information from the file for use
  84. 2160   T2$ = F2$
  85. 2170   REM Convert to Upper Case
  86. 2180   ONE$ = LEFT$(T2$,1)
  87. 2190   ONE = ASC(ONE$)
  88. 2200   IF ONE >= 97 AND ONE <= 122 THEN ONE = ONE - 32
  89. 2210   ONE$ = CHR$(ONE)
  90. 2220   REM Test if out of range
  91. 2230   IF ONE$ < BEGIN.LTR$ OR ONE$ > END.LTR$ THEN 2360
  92. 2240   REM Right-trim t2$
  93. 2250   FOR J = 1 TO LEN(F2$) -1
  94. 2260    IF RIGHT$(T2$,1)=" " THEN T2$=LEFT$(T2$,LEN(T2$)-1) ELSE J=LEN(F2$)-1
  95. 2270   NEXT J
  96. 2280   T3$ = F3$
  97. 2290   FOR J = 1 TO LEN(F3$) -1
  98. 2300    IF RIGHT$(T3$,1)=" " THEN T3$=LEFT$(T3$,LEN(T3$)-1) ELSE J=LEN(F3$)-1
  99. 2310   NEXT J
  100. 2320   PERS.ID(C) = PERS.ID(I)
  101. 2330   MARR.ID(C) = MARR.ID(I)
  102. 2340   IDX$(C) = T2$+T3$
  103. 2350  C = C + 1
  104. 2360  C = C - 1
  105. 2370  NEXT I
  106. 2380  LOCATE 23,1 : PRINT SPACE$(79)
  107. 2390  REM Sort the index into ascending sequence
  108. 2400  LOCATE 19,1 : PRINT SPACE$(79);
  109. 2410  LOCATE 19,1 : PRINT "Sorting";C;"Records";
  110. 2420  FOR I = 1 TO 6
  111. 2430   B(I) = B(I-1)*4+1
  112. 2440   IF B(I) <= C/2 THEN K1 = I
  113. 2450  NEXT I
  114. 2460  B(K1) = INT(C/5)+1
  115. 2470  B(1) = 1
  116. 2480  FOR I = K1 TO 1 STEP -1
  117. 2490  LOCATE 23,1 : PRINT "Sorting Group:";I
  118. 2500   K1 = B(I)
  119. 2510   FOR J = K1 TO C
  120. 2520    LOCATE 23,20 : PRINT "J:";J;
  121. 2530    K2$ = IDX$(J) : TEMP1 = PERS.ID(J) : TEMP2 = MARR.ID(J)
  122. 2540    FOR K = J-K1 TO 0 STEP -K1
  123. 2550     LOCATE 23,30 : PRINT "Freespace:";FRE(0)
  124. 2560     IF K2$ > IDX$(K) THEN 2590
  125. 2570     IDX$(K+K1)=IDX$(K): PERS.ID(K+K1)=PERS.ID(K): MARR.ID(K+K1)=MARR.ID(K)
  126. 2580    NEXT K
  127. 2590    IDX$(K+K1)=K2$: PERS.ID(K+K1)=TEMP1: MARR.ID(K+K1)=TEMP2
  128. 2600   NEXT J
  129. 2610  NEXT I
  130. 2620  LOCATE 21,1 : PRINT "Printing the Alphabetical List"
  131. 2630  GOSUB 2650
  132. 2640  GOTO 2700
  133. 2650  LPRINT "   Alphabetic Listing of the Marriages File   ";DATE$;"   ";TIME$
  134. 2660  LPRINT
  135. 2670  LPRINT "  REC    SURNAME              GIVEN-NAMES";TAB(62);"BIRTHDATE"
  136. 2680  LPRINT "  ---    -------              -----------";TAB(62);"---------"
  137. 2690  RETURN
  138. 2700  REM Read all records, and print the actual ones
  139. 2710  K = 0
  140. 2720  LOCATE 24,1 : PRINT SPACE$(79);
  141. 2730  LOCATE 23,1 : PRINT SPACE$(79);
  142. 2740  FOR I = 1 TO C
  143. 2750   GET #1, ABS(PERS.ID(I))
  144. 2760   LOCATE 23,1 : PRINT "Printing Record:"; I, "Freespace:";FRE(0)
  145. 2770   REM Print the information in Alphabetical Order.
  146. 2780   T1! = CVS(F1$) : T1 = T1!
  147. 2790   IF T1 < 1 THEN 2870
  148. 2800   K = K + 1
  149. 2810   T2$ = F2$
  150. 2820   T3$ = F3$
  151. 2830   T8$ = F8$
  152. 2840   LPRINT USING "#####";MARR.ID(I);
  153. 2850   LPRINT TAB(10); T2$; " "; T3$; TAB(62); T8$
  154. 2860   IF K MOD 55 = 0 THEN LPRINT FORM.FEED$;: GOSUB 2650
  155. 2870  NEXT I
  156. 2880  LPRINT FORM.FEED$;
  157. 2890  KEY ON : CLS : KEY OFF
  158. 2900  LOCATE 24,1 : PRINT "y (yes) or n (no)";
  159. 2910  LOCATE 23,1 : INPUT "Would you like another copy"; REPLY$
  160. 2920  IF LEFT$(REPLY$,1) = "y" OR LEFT$(REPLY$,1) = "Y" THEN 2620
  161. 2930  CLOSE #1
  162. 2940  CLOSE #2
  163. 2950  KEY ON : CLS : KEY OFF : LOCATE 21,1
  164. 2960  PRINT "End of Program
  165. 2970  RUN DD.MENU$+"menu"
  166.